Point Programming 1/PPROG1.ISO/pascal/swag/win-os2.swg/0052_Simple Termianl emulator for WINDOWS.pas

Pascal/Delphi Source File | 1995-02-28 | 10.0 KB | 361 lines

{
  This program demonstrates a simple terminal emulator using
  Serial Communications.  Windows provides support for the
  communications port so your program will be able to poll the
  port and send/recieve data from a remote location.

  Since this is not a program that Borland International has
  developed through normal quality channels, we do not provide
  technical support or establish bug lists for this demonstration
  program.  It is for the sole purpose of demonstrating the use
  of the available functions.
}


Program Terminal;

uses WinTypes, WinProcs, WObjects, Strings;
const
  idEdit     = 100;
  LineWidth  = 80;  { Width of each line displayed.                  }
  LineHeight = 60;  { Number of lines that are held in memory.       }

  { The configuration string below is used to configure the modem.  }
  { It is set for communication port 2, 2400 baud, No parity, 8 data }
  { bits, 1 stop bit.                                                }

  Config = 'com2:24,n,8,1';
  CPort = 'com2';

  { An example of using communication port 1, 1200 baud, Even parity }
  { 7 data bits, 2 stop bits.                                        }
  {  Config = 'com1:12,e,7,2';                                       }


type
  TApp = object(TApplication)
    procedure Idle; virtual;
    procedure InitMainWindow; virtual;
    procedure MessageLoop; virtual;
  end;

  PBuffer = ^TBuffer;
  TBuffer = object(TCollection)
    Pos: Integer;
    constructor Init(AParent: PWindow);
    procedure FreeItem(Item: Pointer); virtual;
    function PutChar(C: Char): Boolean;
  end;

  PCommWindow = ^TCommWindow;
  TCommWindow = object(TWindow)
    Cid: Integer;
    Buffer: PBuffer;
    FontRec: TLogFont;
    CharHeight: Integer;
    constructor Init(AParent: PWindowsObject; ATitle: PChar);
    destructor Done; virtual;
    procedure Error(E: Integer; C: PChar);
    procedure Paint(PaintDC: HDC; var PaintInfo: TPaintStruct); virtual;
    procedure ReadChar; virtual;
    procedure SetHeight;
    procedure SetUpWindow; virtual;
    procedure wmChar(var Message: TMessage);
      virtual wm_Char;
    procedure wmSize(var Message: TMessage);
      virtual wm_Size;
    procedure WriteChar;
  end;

{ TBuffer }
{ The Buffer is used to hold each line that is displayed in the main   }
{ window.  The constant LineHeight determines the number of lines that }
{ are stored.  The Buffer is preloaded with the LineHeight worth of    }
{ lines.                                                               }
constructor TBuffer.Init(AParent: PWindow);
var
  P: PChar;
  I: Integer;
begin
  TCollection.Init(LineHeight + 1, 10);
  GetMem(P, LineWidth + 1);
  P[0] := #0;
  Pos := 0;
  Insert(P);
  for I := 1 to LineHeight do
  begin
    GetMem(P, LineWidth + 1);
    P[0] := #0;
    Insert(P);
  end;
end;

procedure TBuffer.FreeItem(Item: Pointer);
begin
  FreeMem(Item, LineWidth + 1);
end;

{ This procedure processes all incomming in formation from the comm }
{ port.  This procedure is called by TCommWindow.ReadChar.           }

function TBuffer.PutChar(C: Char): Boolean;
var
  Width: Integer;
  P: PChar;
begin
  PutChar := False;
  Case C of
    #13: Pos := 0;                          { if a Carriage Return.  }
    #10:                                    { if a Line Feed.        }
      begin
        GetMem(P, LineWidth + 1);
        FillChar(P^, LineWidth + 1, ' ');
        P[Pos] := #0;
        Insert(P);
      end;
    #8:
      if Pos > 0 then                       { if a Delete.           }
      begin
        Dec(Pos);
        P := At(Count - 1);
        P[Pos] := ' ';
      end;
   #32..#128:                               { else handle all other  }
    begin                                   { displayable characters.}
      P := At(Count - 1);
      Width := StrLen(P);
      if Width > LineWidth then             { if line is to wide     }
      begin                                 { create a new line.     }
        Pos := 1;
        GetMem(P, LineWidth + 1);
        P[0] := C;
        P[1] := #0;
        Insert(P);
      end
      else                                   { else add character    }
      begin                                  { to current line.      }
        P[Pos] := C;
        Inc(Pos);
        P[Pos] := #0;
      end;
    end;
  end;
  if Count > LineHeight then                 { if more to many lines }
  begin                                      { have been added delete}
    AtFree(0);                               { current line and let  }
    PutChar := True;                         { the call procedure    }
  end;                                       { know to scroll up.    }
end;

{ TCommWindow }
{ The CommWindow displays the incoming and out goinging text.  Note   }
{ that the text type by the use is displayed by                      }
{ being echoed back to the ReadChar procedure.  So there is no need for }
{ wmChar to write a character to the screen.                          }
constructor TCommWindow.Init(AParent: PWindowsObject; ATitle: PChar);
begin
  TWindow.Init(AParent, ATitle);
  Attr.Style := Attr.Style or ws_VScroll;
  Scroller := New(PScroller, Init(@Self, 1, 1, 100, 100));
  Buffer := New(PBuffer, Init(@Self));
end;

{ Close the Comm port and deallocate the Buffer.                      }
destructor TCommWindow.Done;
begin
  Error(CloseComm(Cid), 'Close');
  Dispose(Buffer, Done);
  TWindow.Done;
end;

{ Checks for comm errors and writes any errors.                       }
procedure TCommWindow.Error(E: Integer; C: PChar);
var
  S: array[0..100] of Char;
begin
  if E >= 0 then exit;
  Str(E, S);
  MessageBox(GetFocus, S, C, mb_Ok);
end;

{ Redraw all the lines in the buffer by using ForEach.                }
procedure TCommWindow.Paint(PaintDC: HDC; var PaintInfo: TPaintStruct);
var
  I: Integer;
  Font: HFont;

  procedure WriteOut(Item: PChar); far;
  begin
    TextOut(PaintDC, 0, CharHeight * I, Item, StrLen(Item));
    inc(I);
  end;

begin
  I := 0;
  Font := SelectObject(PaintDC, CreateFontIndirect(FontRec));
  Buffer^.ForEach(@WriteOut);
  DeleteObject(SelectObject(PaintDC, Font));
end;

{ Read a charecter from the comm port, if there is no error then call }
{ Buffer^.PutChar to add it to the buffer and write it to the screen. }
procedure TCommWindow.ReadChar;
var
  Stat: TComStat;
  I, Size: Integer;
  C: Char;
begin
  GetCommError(CID, Stat);
  for I := 1 to Stat.cbInQue do
  begin
    Size := ReadComm(CId, @C, 1);
    Error(Size, 'Read Comm');
    if C <> #0 then
    begin
      if Buffer^.PutChar(C) then
      begin
        ScrollWindow(HWindow, 0, -CharHeight, Nil, Nil);
        UpDateWindow(HWindow);
      end;
      WriteChar;
    end;
  end;
end;

procedure TCommWindow.SetUpWindow;
var
  DCB: TDCB;
begin
  TWindow.SetUpWindow;
  SetHeight;

{ Open for Comm2 2400 Baud, No Parity, 8 Data Bits, 1 Stop Bit }

  BuildCommDCB(Config, DCB);
  Cid := OpenComm('COM2', 1024, 1024);
  Error(Cid, 'Open');
  DCB.ID := CID;
  Error(SetCommState(DCB), 'Set Comm State');
  WriteComm(Cid, 'ATZ'#13#10, 5);  { Send a reset to Modem. }
end;

{ Call back function used only in to get record structure for fixed   }
{ width font.                                                         }
function GetFont(LogFont: PLogFont; TM: PTextMetric; FontType: Word;
  P: PCommWindow): Integer; export;
begin
  if P^.CharHeight = 0 then
  begin
    P^.FontRec := LogFont^;
    P^.CharHeight := P^.FontRec.lfHeight;
  end;
end;

{ Get the a fixed width font to use in the TCommWindow.  Use EnumFonts  }
{ to save work of create the FontRec by hand.                         }
{ The TScroller of the main window is also updated know that the font }
{ height is known.                                                    }

procedure TCommWindow.SetHeight;
var
  DC: HDC;
  ProcInst: Pointer;
begin
  DC := GetDC(HWindow);
  CharHeight := 0;
  ProcInst := MakeProcInstance(@GetFont, HInstance);
  EnumFonts(DC, 'Courier', ProcInst, @Self);
  FreeProcInstance(ProcInst);
  ReleaseDC(HWindow, DC);

  Scroller^.SetUnits(CharHeight, CharHeight);
  Scroller^.SetRange(LineWidth, LineHeight);
  Scroller^.ScrollTo(0, LineHeight);
end;


{ Write the character from the pressed key to the Communication Port.   }
procedure TCommWindow.wmChar(var Message: TMessage);
begin
  if CID <> 0 then
    Error(WriteComm(CId, @Message.wParam, 1), 'Writing');
end;

procedure TCommWindow.wmSize(var Message: TMessage);
begin
  TWindow.wmSize(Message);
  Scroller^.SetRange(LineWidth, LineHeight -
                    (Message.lParamhi div CharHeight));
end;

procedure TCommWindow.WriteChar;
var
  DC: HDC;
  Font: HFont;
  S: PChar;
  APos: Integer;
begin
  APos := Buffer^.Count - 1;
  S := Buffer^.AT(APos);
  APos := (APos - Scroller^.YPos) * CharHeight;
  if APos < 0 then exit;
  if Hwindow <> 0 then
  begin
    DC := GetDC(HWindow);
    Font := SelectObject(DC, CreateFontIndirect(FontRec));
    TextOut(DC, 0, APos, S, StrLen(S));
    DeleteObject(SelectObject(DC, Font));
    ReleaseDC(HWindow, DC);
  end;
end;

{ TApp }
procedure TApp.Idle;
var
  Stat: TComStat;
  I, Size: Integer;
  C: Char;
begin
  if MainWindow <> Nil then
    if MainWindow^.HWindow <> 0 then
      PCommWindow(MainWindow)^.ReadChar;
end;

procedure TApp.InitMainWindow;
begin
  MainWindow := New(PCommWindow, Init(Nil, 'Comm Test'));
end;

{ Add Idle loop to main message loop used for polling.               }
procedure TApp.MessageLoop;
var
  Message: TMsg;
begin
  while True do
  begin
    if PeekMessage(Message, 0, 0, 0, pm_Remove) then
    begin
      if Message.Message = wm_Quit then
      begin
        Status := Message.WParam;
        Exit;
      end;
      if not ProcessAppMsg(Message) then
      begin
        TranslateMessage(Message);
        DispatchMessage(Message);
      end;
    end
    else
      Idle;
  end;
end;

var
  App: TApp;
begin
  App.Init('Comm');
  App.Run;
  App.Done;
end.